/* Definitions for the symbol and package types.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include <cstdlib>
#include <cstdio>
#include "khipu.hpp"
#include "dynlib.hpp"

KP_DECLS_BEGIN

static const int PKG_BASE_SIZE = 32;

// Special entries in the symbol table.
static const object PKG_EMPTY = fixint (0);
static const object PKG_DELETED = fixint (1);

static result<void> pkg_inherit_builtins (interpreter *, package *);

static void
fini_pkg (finobj *ptr)
{
  package *self = (package *)ptr;
  if (self->pkg_link.linked_p ())
    self->pkg_link.del ();
}

static inline result<object>
alloc_pkg_syms (interpreter *interp, uint32_t size = PKG_BASE_SIZE)
{
  object ax = KP_TRY (alloc_array (interp, size + 1, PKG_EMPTY));
  array *ap = as_array (ax);
  ap->data[0] = 0;
  ++ap->data, --ap->len;
  return (interp->alval);
}

static inline object&
syms_len (array *ap)
{
  return (*(ap->data - 1));
}

static result<object> alloc_pkg_aux (interpreter *interp, object name,
                                     object path, bool bootstrap)
{
  auto eg = KP_TRY (evh_guard::make (interp));
  auto ret = alloch<package> ();

  lwlock_init (&ret->lock);
  ret->name = name;
  ret->syms = ret->path = UNBOUND;
  ret->canonical_path = path;

  valref alval (interp, ret->as_obj ());
  ret->syms = KP_TRY (alloc_pkg_syms (interp));

  if (!bootstrap)
    KP_VTRY (pkg_inherit_builtins (interp, ret));

  ret->fini = fini_pkg;
  gc_register (interp, ret);
  return (interp->alval = *alval);
}

result<object> alloc_pkg (interpreter *interp, object name, bool bootstrap)
{
  return (alloc_pkg_aux (interp, name, UNBOUND, bootstrap));
}

result<object> alloc_pkg (interpreter *interp, object name, object path)
{
  return (alloc_pkg_aux (interp, name, path, false));
}

static void
fini_sym (finobj *ptr)
{
  symbol *symp = (symbol *)ptr;
  if (symp->pkg == NIL || symp->idx < 0)
    return;

  array *ap = as_array (as_package(symp->pkg)->syms);
  ap->data[symp->idx] = PKG_DELETED;
  if (kp_unlikely (--syms_len (ap) == 0))
    for (uint32_t i = 0; i < ap->len; ++i)
      ap->data[i] = PKG_EMPTY;
}

result<object> alloc_sym (interpreter *interp, uint32_t flags)
{
  auto eg = KP_TRY (evh_guard::make (interp));
  symbol *ret = alloch<symbol> ();

  ret->name = ret->value = UNBOUND;
  ret->pkg = NIL;
  ret->idx = -1;
  ret->tl_idx = 0;
  ret->fini = fini_sym;
  ret->vo_full |= flags | FLAGS_FINALIZABLE;

  interp->alval = ret->as_obj ();
  gc_register (interp, ret);

  if (flags & symbol::special_flag)
    { ret->tl_idx = KP_TRY (symbol::alloc_tl_idx (interp)); }

  return (interp->alval);
}

result<object> copy_S (interpreter *interp, object obj, bool deep)
{
  if (!deep)
    kp_return (obj);

  object ret = KP_TRY (alloc_sym (interp));
  symname(ret) = symname (obj);
  symtlidx(ret) = symtlidx (obj);
  kp_return (ret);
}

static const uint32_t SYMBOL_HASH_SEED = 0x81623974;

uint32_t hash_S (interpreter *interp, object obj)
{
  object pkg = sympkg (obj);
  uint32_t ret = SYMBOL_HASH_SEED;

  if (package_p (pkg))
    ret = mix_hash (ret, hash_P (interp, pkg));

  return (mix_hash (ret, hash_s (interp, symname (obj))));
}

static object*
pkg_lookup (interpreter *interp, const array *ap, object name)
{
  uint32_t bucket = hash_s (interp, name) & (ap->len - 1);
  uint32_t nprobe = 1;

  while (true)
    {
      object *ptr = &ap->data[bucket];
      if ((interp->retval = *ptr) != PKG_DELETED &&
          (interp->retval == PKG_EMPTY ||
           eq_bb (interp, symname (interp->retval), name)))
        return (ptr);

      bucket = (bucket + nprobe++) & (ap->len - 1);
    }
}

object find_sym (interpreter *interp, object pkg, object name)
{
  return (*pkg_lookup(interp, as_array (as_package(pkg)->syms), name));
}

object find_sym (interpreter *interp, object pkg,
                 const char *name, uint32_t len)
{
  local_varobj<string> str;
  str.local_init (name, len);
  return (find_sym (interp, pkg, str.as_obj ()));
}

object find_sym (interpreter *interp, object pkg, const char *name)
{
  return (find_sym (interp, pkg, name, (uint32_t)strlen (name)));
}

static result<void>
pkg_resize (interpreter *interp, package *pkg, uint32_t nlen)
{
  KP_VTRY (alloc_pkg_syms (interp, nlen));
  array *np = as_array (interp->alval);
  array *ap = as_array (pkg->syms);

  for (uint32_t i = 0, j = 0; j < syms_len (ap); ++i)
    {
      object obj = ap->data[i];

      if (fixint_p (obj))
        continue;

      uint32_t bucket = hash_s (interp, symname (obj)) & (nlen - 1);
      uint32_t nprobe = 1;

      while (true)
        {
          if (np->data[bucket] == PKG_EMPTY)
            {
              np->data[bucket] = obj;
              if (sympkg (obj) == pkg->as_obj ())
                as_symbol(obj)->idx = bucket;

              break;
            }

          bucket = (bucket + nprobe++) & (nlen - 1);
        }

      ++j;
    }

  syms_len(np) = syms_len (ap);
  pkg->syms = np->as_obj ();
  return (0);
}

static result<object>
pkg_insert (interpreter *interp, package *pkg, object name,
            uint32_t flags, bool locked = false)
{
  interp->aux = pkg->syms;
  object *ptr = pkg_lookup (interp, as_array (interp->aux), name);

  if (interp->retval != PKG_EMPTY)
    {
      interp->aux = fixint (0);
      return (interp->retval);
    }

  // The lookup came up empty - See if we need to insert.
  lwlock_guard g;

  if (!locked && !singlethr_p ())
    {
      KP_VTRY (g.set (interp, &pkg->lock));
      if (pkg->syms != interp->aux || *ptr != PKG_EMPTY)
        { /* Either the symbol table moved or another thread inserted
           * a symbol in the entry we needed - Look it up again. */
          ptr = pkg_lookup (interp, as_array (pkg->syms), name);
          if (*ptr != PKG_EMPTY)
            // The symbol is already present - We're done.
            return (interp->retval);
        }
    }

  /* We are alone, and we know the entry is empty. Allocate
   * the symbol, insert it and update the symbol count. */

  if (as_varobj(name)->vo_type != typecode::STR)
    { // We need a string as the symbol name.
      string *sp = as_str (name);
      object s = KP_TRY (string::make (interp, sp->data, sp->nbytes));
      as_str(s)->hval = as_str(name)->hval;
      name = s;
    }

  {
    valref tmp (interp, name);
    *ptr = KP_TRY (alloc_sym (interp, flags));
    symname(*ptr) = *tmp;
  }

  sympkg(*ptr) = pkg->as_obj ();
  interp->retval = interp->alval;

  // Resize the table if it gets too dense.
  array *symp = as_array (pkg->syms);
  if (kp_unlikely (symp->len * 75 <= ++syms_len(symp) * 100))
    {
      valref tmp (interp, interp->retval);
      KP_VTRY (pkg_resize (interp, pkg, symp->len * 4));
      interp->retval = *tmp;
    }
  else
    as_symbol(*ptr)->idx = ptr - symp->data;

  interp->aux = fixint (0);
  return (interp->retval);
}

static result<object>
pkg_insert_sym (interpreter *interp, package *pkg,
                object sym, bool locked = false)
{
  /* Same as above, only this function allows us to insert
   * pre-existing symbols into a package. */
  interp->aux = pkg->syms;
  object name = symname (sym);
  object *ptr = pkg_lookup (interp, as_array (interp->aux), name);

  if (interp->retval != PKG_EMPTY && symval (*ptr) != UNBOUND)
    {
      interp->aux = fixint (0);
      return (interp->retval);
    }

  lwlock_guard g;

  if (!locked && !singlethr_p ())
    {
      KP_VTRY (g.set (interp, &pkg->lock));
      if (pkg->syms != interp->aux || *ptr != PKG_EMPTY)
        {
          ptr = pkg_lookup (interp, as_array (pkg->syms), symname (sym));
          if (interp->retval != PKG_EMPTY)
            return (interp->retval);
        }
    }

  interp->retval = *ptr = sym;

  array *symp = as_array (pkg->syms);
  if (kp_unlikely (symp->len * 75 <= ++syms_len(symp) * 100))
    {
      valref tmp (interp, interp->retval);
      KP_VTRY (pkg_resize (interp, pkg, symp->len * 4));
      interp->retval = sym;
    }
  else if (sympkg (sym) == pkg->as_obj ())
    as_symbol(sym)->idx = ptr - symp->data;

  interp->aux = fixint (0);
  return (interp->retval);
}

static result<bool>
pkg_remove (interpreter *interp, package *pkg, object name)
{
  bool ret = false;
  lwlock_guard g;

  /* Deletions are much more infrequent than insertions, so we 
   * grab the lock inconditionally here. */
  KP_MT_BEGIN (KP_VTRY (g.set (interp, &pkg->lock)));
  object *ptr = pkg_lookup (interp, as_array (pkg->syms), name);

  if (symbol_p (*ptr))
    {
      array *symp = as_array (pkg->syms);

      symval(*ptr) = UNBOUND;
      as_symbol(*ptr)->idx = -1;
      *ptr = PKG_DELETED;
      ret = true;

      // Resize the table if it gets too sparse.
      if (symp->len * 25 >= --syms_len(symp) &&
          symp->len > PKG_BASE_SIZE)
        KP_VTRY (pkg_resize (interp, pkg, (symp->len - 1) / 4));
      else if (kp_unlikely (!syms_len (symp)))
        /* Prevent an infinite loop in lookups by 
         * reinitialising the table. */
        for (uint32_t i = 0; i < PKG_BASE_SIZE; ++i)
          symp->data[i] = PKG_EMPTY;
    }

  return (ret);
}

result<object> intern (interpreter *interp, const string *name,
                       package *pkgp, uint32_t flags)
{
  if (!pkgp)
    pkgp = as_package (interp->xpkg);
  else if (pkgp == as_package (kword_package))
    flags |= FLAGS_CONST | symbol::literal_flag;

  object ret = KP_TRY (pkg_insert (interp, pkgp, name->as_obj (), flags));
  if (pkgp == as_package (kword_package))
    symval(ret) = ret;

  return (ret);
}

result<object> intern (interpreter *interp, const char *name,
                       uint32_t len, package *pkgp, uint32_t flags)
{
  local_varobj<string> str;
  str.local_init (name, len);

  /* Forge the type so a new string is created as the name, but
   * only if it's necessary (i.e: If the symbol didn't exist). */
  str.vo_type = typecode::BVECTOR;
  return (intern (interp, &str, pkgp, flags));
}

result<object> intern (interpreter *interp, const char *name,
                       package *pkgp, uint32_t flags)
{
  return (intern (interp, name, strlen (name), pkgp, flags));
}

result<bool> undef (interpreter *interp, const char *name,
                    uint32_t len, package *pkgp)
{
  local_varobj<string> sname;
  sname.local_init (name, len);

  return (pkg_remove (interp, pkgp != nullptr ?
                      pkgp : as_package (interp->xpkg), sname.as_obj ()));
}

package::iterator::iterator (interpreter *interp, object pkg) :
  idx ((uint32_t)-1), symtab (interp, as_package(pkg)->syms), cursym (interp)
{
  ++*this;
}

bool package::iterator::valid () const
{
  return (this->idx < len_a (*this->symtab));
}

package::iterator& package::iterator::operator++ ()
{
  array *ap = as_array (*this->symtab);
  *this->cursym = UNBOUND;

  while (++this->idx < ap->len)
    {
      *this->cursym = ap->data[this->idx];
      if (!fixint_p (*this->cursym))
        break;
    }

  return (*this);
}

result<int64_t> write_S (interpreter *interp, stream *strmp,
                         object obj, io_info&)
{
  const symbol *sp = as_symbol (obj);
  int ret = 0;

  if (sp->pkg == kword_package)
    { ret += KP_TRY (strmp->putb (interp, ':')); }
  else if (sp->pkg == NIL)
    { ret += KP_TRY (strmp->write (interp, "#:", 2)); }
  else if (sp->pkg != root_package && sp->pkg != interp->xpkg)
    {
      string *np = as_str (as_package(sp->pkg)->name);
      ret += KP_TRY (strmp->write (interp, np->data, np->nbytes));
      ret += KP_TRY (strmp->write (interp, "::", 2));
    }

  const string *name = as_str (sp->name);
  ret += KP_TRY (strmp->write (interp, name->data, name->nbytes));
  return (ret);
}

result<int64_t> write_P (interpreter *interp, stream *strmp,
                         object obj, io_info&)
{
  const package *pkgp = as_package (obj);
  int ret = 0;

  ret += KP_TRY (strmp->write (interp, "#<package ", 10));
  const string *namep = as_str (pkgp->name);
  ret += KP_TRY (strmp->write (interp, namep->data, namep->nbytes));
  ret += KP_TRY (strmp->putb (interp, '>'));
  return (ret);
}

enum
{
  PACK_PKG_ROOT = 1,
  PACK_PKG_KWORD = 2,
  PACK_PKG_NONE = 3
};

static inline int
pkg_number (object obj)
{
  return (obj == root_package ? PACK_PKG_ROOT :
          obj == kword_package ? PACK_PKG_KWORD :
          obj == NIL ? PACK_PKG_NONE : 0);
}

static inline uint32_t
sym_pack_flags (const symbol *symp)
{
  return (symp->vo_full & (symbol::special_flag | symbol::ctv_flag |
                           symbol::alias_flag | symbol::specform_flag));
}

result<int64_t> pack_S (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  uint32_t flags = sym_pack_flags (as_symbol (obj));
  int64_t ret = KP_TRY (strm->write (interp, &flags));

  if (flags & symbol::specform_flag)
    for (uint32_t i = 0; i < symbol::N_SPECFORMS; ++i)
      if (obj == symbol::fast_global_syms[i])
        {
          ret += KP_TRY (strm->putb (interp, i));
          return (ret);
        }

  ret += KP_TRY (xpack (interp, strm, symname (obj), info));
  ret += KP_TRY (xpack (interp, strm, sympkg (obj), info));
  return (ret);
}

static const uint32_t PKG_HASH_SEED = 0x96183520;

uint32_t hash_P (interpreter *interp, object obj)
{
  const auto pkg = as_package (obj);
  uint32_t ret = pkg_number (obj);

  if (!ret)
    ret = hash_s (interp, pkg->canonical_path);
  return (mix_hash (PKG_HASH_SEED, ret));
}

result<int64_t> pack_P (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  int pn = pkg_number (obj);
  if (pn != 0)
    return (xpack (interp, strm, fixint (pn), info));

  object path = as_package(obj)->path;
  if (path == UNBOUND)
    path = as_package(root_package)->path;

  return (xpack (interp, strm, path, info));
}

result<object> unpack_S (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  uint32_t flags;
  valref saved_pos (interp, *info.offset), ret (interp);

  {
    bool rv = KP_TRY (strm->sread (interp, &flags));
    if (!rv)
      return (info.error ("invalid symbol flags"));
  }

  if (flags & symbol::specform_flag)
    {
      int idx = KP_TRY (strm->getb (interp));
      if (idx < 0 || idx >= (int)symbol::N_SPECFORMS)
        return (info.error ("invalid special form index"));

      *ret = symbol::fast_global_syms[idx];
    }
  else
    {
      *ret = KP_TRY (xunpack (interp, strm, info));
      if (!str_p (*ret))
        return (info.error ("invalid symbol name"));

      object pkg = KP_TRY (xunpack (interp, strm, info));
      if (pkg == NIL)
        { // Uninterned symbol.
          object sym = KP_TRY (alloc_sym (interp));
          symname(sym) = *ret, *ret = sym;
        }
      else if (!package_p (pkg))
        return (info.error ("invalid symbol package"));
      else
        { *ret = KP_TRY (intern (interp, as_str (*ret),
                               as_package (pkg), flags)); }
    }

  if (save)
    KP_VTRY (info.add_mapping (interp, *saved_pos, *ret));
  kp_return (*ret);
}

static result<object> import_pkg (interpreter *, object, object);

result<object> unpack_P (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  object path = KP_TRY (xunpack (interp, strm, info));
  valref saved_pos (interp, *info.offset);

  if (fixint_p (path))
    switch (as_int (path))
      {
        case PACK_PKG_ROOT:
          kp_return (root_package);
        case PACK_PKG_KWORD:
          kp_return (kword_package);
        case PACK_PKG_NONE:
          kp_return (NIL);
        default:
          return (info.error ("invalid package designator"));
      }
  else if (!str_p (path))
    return (info.error ("invalid package path"));

  valref ret (interp, path);
  *ret = KP_TRY (import_pkg (interp, *ret, UNBOUND));
  if (save)
    KP_VTRY (info.add_mapping (interp, *saved_pos, *ret));

  kp_return (*ret);
}

// XXX: Should we expose this counter?
static atomic_t gensym_cnt;

result<object> gensym (interpreter *interp, object *, int)
{
  char space[64] = "G";
  char *bufp = &space[1];
  atomic_t val = atomic_add (&gensym_cnt, 1);

  do
    {
      atomic_t digit = val % 32;
      *bufp++ = digit < 10 ? '0' + digit : 'a' + digit - 10;
    }
  while ((val /= 32) != 0);

  valref ret = KP_TRY (alloc_sym (interp));
  as_symbol(*ret)->name = KP_TRY (string::make (interp, space,
                                                bufp - &space[0]));
  kp_return (*ret);
}

result<object> symbol::make_kword (interpreter *interp, object name)
{
  return (intern (interp, as_str (name), as_package (kword_package)));
}

result<object> symbol::make_kword (interpreter *interp,
                                   const char *name, int len)
{
  return (intern (interp, name, len, as_package (kword_package)));
}

result<object> symbol::make_kword (interpreter *interp, const char *name)
{
  return (symbol::make_kword (interp, name, (int)strlen (name)));
}

static result<void>
pkg_inherit_builtins (interpreter *interp, package *dstp)
{
  // XXX: This will need to be revised once we have a working system image.
  array *ap = as_array (dstp->syms);
  for (package::iterator it { interp, root_package }; it.valid (); ++it)
    {
      object s = *it;
      if (symval (s) == UNBOUND &&
          !as_symbol(s)->flagged_p (symbol::specform_flag))
        continue;

      *pkg_lookup(interp, ap, symname (s)) = s;
      if (ap->len * 75 <= ++syms_len(ap) * 100)
        {
          KP_VTRY (pkg_resize (interp, dstp, ap->len * 4));
          ap = as_array (dstp->syms);
        }
    }

  return (0);
}

static inline result<object>
ensure_symname (interpreter *interp, object key)
{
  if (keyword_p (key))
    return (symname (key));
  else if (str_p (key))
    return (key);

  return (interp->raise ("type-error",
                         KP_SPRINTF (interp,
                                     "symbol name must be a string or keyword,"
                                     " not %Q", type (key))));
}

result<object> get_P (interpreter *interp, object pkg, object key, object dfl)
{
  if (kp_unlikely (dfl != UNBOUND))
    return (interp->raise_nargs (2, 2, 3));

  key = KP_TRY (ensure_symname (interp, key));
  valref ret (interp, find_sym (interp, pkg, key));
  *ret = !symbol_p (*ret) ? UNBOUND : symval (*ret);

  if (*ret == UNBOUND)
    return (interp->raise ("unbound-error",
                           KP_SPRINTF (interp,
                                       "symbol named %Q is unbound", key)));

  kp_return (*ret);
}

result<object> nput_P (interpreter *interp, object pkg, object key, object val)
{
  key = KP_TRY (ensure_symname (interp, key));
  valref sym = KP_TRY (intern (interp, as_str (key), as_package (pkg)));
  kp_return (symval(*sym) = val);
}

// Importing of packages.

static const char*
path_basename (const char *path, size_t len)
{
  const char *ret = (const char *)memchr (path, '/', len);
  if (!ret++)
    return (path);

  for (len -= ret - path ; ; )
    {
      const char *tmp = (const char *)memchr (ret, '/', len);
      if (!tmp)
        return (ret);

      len -= tmp - ret;
      ret = tmp + 1;
    }
}

static inline void
register_pkg (package *p, dlist *node)
{
  dlist *lp = &p->pkg_link;
  lp->next = node;
  lp->prev = node->prev;
  node->prev->next = lp;
  node->prev = lp;
}

struct import_data
{
  static const uint32_t only_kpfiles = 1;
  static const uint32_t only_dynlibs = 2;

  interpreter *interp;
  valref dir;
  valref strm;
  valref kpc;
  valref prev;
  valref canonical_path;
  const char *name = nullptr;
  void *dynlib = nullptr;
  uint32_t flags = 0;
  package *rpkg = nullptr;

  import_data (interpreter *ip) : interp (ip),
      dir (ip, UNBOUND), strm (ip, UNBOUND),
      kpc (ip, UNBOUND), prev (ip, UNBOUND),
      canonical_path (ip, UNBOUND)
    {
    }

  ~import_data ()
    {
      evh_safeguard eg { this->interp };
      if (*this->strm != UNBOUND)
        deref (as_stream(*this->strm)->close (interp));
      if (*this->kpc != UNBOUND)
        deref (as_stream(*this->kpc)->close (interp));
      if (this->dynlib != nullptr)
        dynlib_close (this->dynlib);
      if (*this->prev != UNBOUND)
        this->interp->xpkg = *this->prev;

      if (this->rpkg != nullptr)
        this->rpkg->pkg_link.del ();
    }

  object set_pkg (package *p, dlist *node)
    {
      if (!node)
        {
          this->rpkg = nullptr;
          return (p->as_obj ());
        }

      *this->prev = this->interp->xpkg;
      p->path = *this->dir;
      this->interp->xpkg = p->as_obj ();
      register_pkg (this->rpkg = p, node);
      return (UNBOUND);
    }

  void set_flags (const char *name, int len)
    {
#ifndef KP_STATIC
      const char *ext = dynlib_extension ();
      int elen = (int)strlen (ext);

      if (len > elen && memcmp (name + len - elen, ext, elen) == 0)
        this->flags |= only_dynlibs;
      else
#endif
      if (len > 3 && memcmp (name + len - 3, ".kp", 3) == 0)
        this->flags |= only_kpfiles;
    }

  result<bool> open_strm (char *name, int len)
    {
      name[len] = '\0';
      stream *s = KP_TRY (fstream_open (this->interp, name, "r"));
      if (s)
        {
          *this->strm = s->as_obj ();
          *this->canonical_path = KP_TRY (llio_fhpath (this->interp, name));
        }

      name[len] = 'c', name[len + 1] = '\0';
      /* If we can't open the source file, try to open the compiled file
       * in read only mode, since we won't be serializing anything. */
      stream *c = KP_TRY (fstream_open (this->interp, name,
                                        s ? "r+bc" : "rb"));
      if (c)
        {
          *this->kpc = c->as_obj ();
          if (*this->canonical_path == UNBOUND)
            {
              *this->canonical_path = KP_TRY (llio_fhpath (this->interp, name));
              if (*this->canonical_path == UNBOUND)
                return (interp->raise ("io-error",
                                       "could not compute the package's path"));
            }

        }

      return (c != nullptr || s != nullptr);
    }

  result<bool> open (const char *path, int len, object at = UNBOUND)
    {
      tmp_allocator ta { this->interp };

      if (at == UNBOUND)
        at = deref (string::make (interp, "", 0));

      const string *sdir = as_str (at);
      char *sp = (char *)ta.alloc (sdir->nbytes + 16);

      memcpy (sp, sdir->data, sdir->nbytes);
      memcpy (sp + sdir->nbytes, path, len + 1);

      if (this->flags & only_dynlibs)
        return ((this->dynlib = dynlib_open (interp,
                                             sp, DYNLIB_LOCAL)) != nullptr);
      else if (this->flags & only_kpfiles)
        return (this->open_strm (sp, sdir->nbytes + len));

      const char *ext = dynlib_extension ();
      strcpy (sp + sdir->nbytes + len, ext);

      if ((this->dynlib = dynlib_open (interp, sp, DYNLIB_LOCAL)) != nullptr)
        return (true);

      strcpy (sp + sdir->nbytes + len, ".kp");
      return (this->open_strm (sp, sdir->nbytes + len + 3));
    }
};

static result<bool>
open_pkg (interpreter *interp, const string *path, import_data& data)
{
  auto sp = (const char *)path->data;
  int len = path->nbytes;

  data.set_flags (sp, len);

#ifdef KP_PLATFORM_WINDOWS
  if (sp[0] >= 'A' && sp[0] <= 'Z' && len > 3 &&
      sp[1] == ':' && sp[2] == '/')
#else
  if (sp[0] == '/')
#endif
    { // Absolute path.
      bool ret = KP_TRY (data.open (sp, len));

      if (ret)
        {
          data.name = path_basename (sp, len);
          *data.dir = KP_TRY (string::make (interp, sp, data.name - sp));
        }

      return (ret);
    }
  else if (sp[0] == '.' && ((len > 2 && sp[1] == '/') ||
      (len > 3 && sp[1] == '.' && sp[2] == '/')))
    { // Path is relative to current directory.
    relative:
      bool ret =
        KP_TRY (data.open (sp, len,
                           *data.dir = as_package(interp->xpkg)->path));

      if (ret)
        {
          data.name = path_basename (sp, len);
          if (data.name != sp)
            { *data.dir = KP_TRY (string::make (interp, sp, data.name - sp)); }
        }

      return (ret);
    }

  // non-specific path. Try all the base paths in order.
  valref glp (interp, find_sym (interp, "*path*", 6));
  if (!symbol_p (*glp) ||
      (*glp = symval (interp, *glp)) == UNBOUND ||
      !xcons_p (*glp))
    // No global *path* - Just go with the current directory.
    goto relative;

  for (cons::iterator it (interp, *glp); it.valid (); ++it)
    if (str_p (*data.dir = *it))
      {
        bool rv = KP_TRY (data.open (sp, len, *data.dir));
        if (rv)
          {
            data.name = sp;
            return (true);
          }
      }

  return (false);
}

static dlist loaded_packages;
static lock loaded_packages_lock;

static inline int
cmp_paths (const string *p1, const string *p2)
{
  int diff = (int)(p1->nbytes - p2->nbytes);
  return (diff ? diff : memcmp (p1->data, p2->data, p1->nbytes));
}

static inline package*
lookup_pkg (const string *path, dlist*& node)
{
  auto it = loaded_packages.iterator (&package::pkg_link);
  for (; it.valid (); ++it)
    {
      package *p = &*it;
      int r = cmp_paths (as_str (p->canonical_path), path);

      if (r == 0)
        return (p);
      else if (r > 0)
        break;
    }

  node = it.link ();
  return (nullptr);
}

static result<object>
make_pkg_name (interpreter *interp, object name, import_data& dt)
{
  if (name != UNBOUND)
    return (name);

  const char *s = dt.name;
  if (dt.flags & import_data::only_kpfiles)
    return (string::make (interp, s, strrchr (s, '.') - s));
  else
    return (string::make (interp, s));
}

static result<object>
import_pkg_lk (interpreter *interp, object path, object name, import_data& dt)
{
  valref ret (interp, UNBOUND);

  {
    bool rv = KP_TRY (open_pkg (interp, as_str (path), dt));
    if (!rv || dt.dynlib || *dt.canonical_path == UNBOUND)
      kp_return (*ret);
  }

  dlist *node = nullptr;
  package *p = lookup_pkg (as_str (*dt.canonical_path), node);
  if (p != nullptr)
    kp_return (p->as_obj ());

  *ret = KP_TRY (make_pkg_name (interp, name, dt));
  *ret = KP_TRY (alloc_pkg (interp, *ret, *dt.canonical_path));
  p = as_package (*ret);

  if (*dt.kpc != UNBOUND)
    { // Found a compiled package.
      fhandle_stat st1, st2;

      if (*dt.strm != UNBOUND)
        {
          bool rv = KP_TRY (fstream_fstat (interp, as_stream (*dt.strm), st1));
          rv = rv && KP_TRY (fstream_fstat (interp, as_stream (*dt.kpc), st2));
          rv = rv && st1.mtime <= st2.mtime && st2.size;
          if (rv)   // The compiled package is up to date.
            goto execute;
        }
      else
        {
        execute:
          pack_info sin { interp };
          KP_VTRY (sin.init (interp, false));
          KP_VTRY (sin.add_mapping (interp, fixint (-1), *ret));
          object expr = KP_TRY (xunpack (interp, as_stream (*dt.kpc), sin));
          if (fct_p (expr))
            {
              dt.set_pkg (p, node);
              KP_VTRY (interp->push (expr));
              KP_VTRY (call_n (interp, 0));
              kp_return (dt.set_pkg (p, nullptr));
            }

          KP_VTRY (as_stream(*dt.kpc)->seek (interp, fixint (0), SEEK_SET));
        }
    }

  if (*dt.strm == UNBOUND)
    kp_return (UNBOUND);

  reader rd (interp, *dt.strm, p);
  // Switch packages before executing any code.
  dt.set_pkg (p, node);

  // Compile the package and (optionally) serialize it.
  valref c_expr = KP_TRY (compile_pkg (interp, rd));
  if (*dt.kpc != UNBOUND)
    {
      bool rv = KP_TRY (fstream_truncate (interp, as_stream (*dt.kpc), 0));
      if (rv)
        KP_VTRY (xpack_with (interp, as_stream (*dt.kpc),
                             *c_expr, *ret, fixint (-1)));
    }

  kp_return (dt.set_pkg (p, nullptr));
}

static result<object>
import_pkg (interpreter *interp, object path, object name)
{
  import_data dt { interp };
  valref ret (interp, UNBOUND);

  {
    lock_guard lg (interp, &loaded_packages_lock);
    *ret = KP_TRY (import_pkg_lk (interp, path, name, dt));
  }

  if (*ret == UNBOUND)
    kp_return (*ret);

  package *p = as_package (*ret);
  if (p->path == UNBOUND)
    p->path = path;

  kp_return (*ret);
}

result<uintptr_t> symbol::alloc_tl_idx (interpreter *interp)
{
  static atomic_t index = 0;

  while (true)
    {
      uintptr_t tmp = index;
      if (tmp >= FIXINT_MAX)
        return (interp->raise ("runtime-error",
                               "thread-local indices exhausted"));
      else if (atomic_cas_bool (&index, tmp, tmp + 1))
        return (tmp + 1);

      atomic_spin_nop ();
    }
}

static inline result<symbol*>
nzap_helper (interpreter *interp, package *pkg,
             const string *name, int stack_idx, object dfl,
             int has_dfl, object& out_sym)
{
  out_sym = KP_TRY (intern (interp, name, pkg));
  symbol *ret = as_symbol (out_sym);

  if (ret->flagged_p (FLAGS_CONST))
    return (interp->raise_const ());
  else if (ret->value != UNBOUND)
    interp->stack[stack_idx] = ret->value;
  else if (!has_dfl)
    return (interp->raise ("unbound-error",
                           KP_SPRINTF (interp, "symbol %Q is unbound",
                                       out_sym)));
  else
    interp->stack[stack_idx] = dfl;

  return (ret);
}

result<object> nzap_P (interpreter *interp, object obj, object key,
                       uint32_t flags, object fn, object *argv, int argc)
{
  key = KP_TRY (ensure_symname (interp, key));

  KP_VTRY (interp->growstk (argc + 1));
  *interp->stkend++ = fn;
  *interp->stkend++ = fixint (0);

  int stack_idx = interp->stklen () - 1;
  int has_dfl = (int)((flags & NZAP_DFL) / NZAP_DFL);

  for (int i = has_dfl; i < argc; ++i)
    *interp->stkend++ = argv[i];

  package *pkg = as_package (obj);
  valref ret (interp), sym (interp);
  const string *name = as_str (key);

  if (kp_likely (flags & NZAP_NOMT))
    {
      symbol *sp = KP_TRY (nzap_helper (interp, pkg, name,
                                        stack_idx, *argv, has_dfl, *sym));

      *ret = sp->value;
      sp->value = KP_TRY (call_n (interp, argc + 1 - has_dfl));
      if (*ret != sp->value)
        deref (gc_wbarrier (interp, *sym, sp->value));
    }
  else
    while (true)
      {
        symbol *sp = KP_TRY (nzap_helper (interp, pkg, name,
                                          stack_idx, *argv, has_dfl, *sym));

        *ret = sp->value;
        KP_VTRY (call_n (interp, argc + 1 - has_dfl));
        if (atomic_cas_bool ((atomic_t *)&sp->value, *ret, interp->retval))
          {
            deref (gc_wbarrier (interp, *sym, interp->retval));
            break;
          }

        atomic_spin_nop ();
      }

  if (flags & NZAP_PREV)
    interp->retval = *ret;

  return (interp->retval);
}

// External definitions.
object root_package;
object kword_package;

object symbol::t;
object symbol::comma;
object symbol::comma_at;
object symbol::comma_dot;
object symbol::backquote;
object symbol::quote;
object symbol::nil;
object symbol::meth_curr;

static const char SPECFORM_NAMES[] =
  "if\0"
  "do\0"
  "fct\0"
  "and\0"
  "or\0"
  "while\0"
  "break\0"
  "continue\0"
  "return\0"
  "setq\0"
  "quote\0"
  "try\0"
  "let\0"
  "recur\0"
  "yield\0"
  "call/cc\0"
  "raise\0"
  ;

int symbol::specform_byname (const void *name, uint32_t len)
{
  for (uint32_t i = 0; i < symbol::N_SPECFORMS; ++i)
    {
      const string *sp = as_str (symname (symbol::fast_global_syms[i]));
      if (sp->nbytes == len && memcmp (name, sp->data, len) == 0)
        return ((int)i);
    }

  return (-1);
}

int symbol::specform_byname (const void *name)
{
  return (symbol::specform_byname (name, strlen ((const char *)name)));
}

static inline bool
kword_eq (object x, const char *s, uint32_t n)
{
  if (!keyword_p (x))
    return (false);

  const string *sp = as_str (symname (x));
  return (sp->nbytes == n && memcmp (sp->data, s, n) == 0);
}

static inline bool
kword_as_p (object x)
{
  return (kword_eq (x, "as", 2));
}

static inline object
pull_list_p (object x, object& name)
{
  if (!xcons_p (x))
    return (UNBOUND);

  object ret = xcar (x);
  if (!nksymbol_p (ret) || !cons_p (x = xcdr (x)) ||
      !kword_as_p (xcar (x)) || !cons_p (x = xcdr (x)) ||
      xcdr (x) != NIL || !symbol_p (name = xcar (x)))
    return (UNBOUND);

  return (ret);
}

enum
{
  pull_noalias,
  pull_alias,
  pull_some,
  pull_all
};

static inline result<void>
check_sym_flags (interpreter *interp, object s1, object s2)
{
  uint32_t fl1 = as_symbol(s1)->vo_flags;
  uint32_t fl2 = as_symbol(s2)->vo_flags;

  const uint32_t sym_flg = symbol::special_flag |
                           symbol::ctv_flag | symbol::alias_flag;

  if (symval (s1) == UNBOUND)
    as_symbol(s1)->vo_flags = fl2;
  else if ((fl1 & sym_flg) != (fl2 & sym_flg))
    return (interp->raise ("pkg-error",
                           KP_SPRINTF (interp, "incompatible flags detected "
                                       "when pulling symbol %Q (const-ness "
                                       "or alias/macro flags)", symname (s1))));

  return (0);
}

static inline result<void>
update_sym (interpreter *interp, package *p, object sym, bool locked = false)
{
  object prev = KP_TRY (pkg_insert_sym (interp, p, sym, locked));
  if (prev == sym)
    return (0);

  KP_VTRY (check_sym_flags (interp, prev, sym));
  // Symbols are compatible - Update the value.
  symval(prev) = symval (sym);
  return (0);
}

result<object> pull_pkg (interpreter *interp, object name,
                         object arg_1, object arg_2)
{
  int method;
  object path = name;
  name = UNBOUND;

  if (!str_p (path))
    return (interp->raise ("type-error", "first argument must be a string"));
  else if (arg_1 == NIL && arg_2 == NIL)
    method = pull_noalias;
  else if (kword_as_p (arg_1))
    {
      if (!str_p (arg_2))
        return (interp->raise ("type-error",
                               "expected a string as third argument"));

      name = arg_2;
      method = pull_alias;
    }
  else if (!kword_eq (arg_1, "pull", 4))
    return (interp->raise ("arg-error",
                           "second argument must be :pull or :as"));
  else if (cons_p (arg_2))
    method = pull_some;
  else if (kword_eq (arg_2, "all", 3))
    method = pull_all;
  else
    return (interp->raise ("arg-error",
                           "third argument must be a list or :all"));

  valref pkg = KP_TRY (import_pkg (interp, path, name));
  if (*pkg == UNBOUND)
    return (interp->raise ("pkg-error",
                           KP_SPRINTF (interp,
                                       "failed to open package %Q", path)));

  package *p = as_package (interp->xpkg);

  if (method == pull_noalias || method == pull_alias)
    {
      object tmp = KP_TRY (intern (interp,
                                   as_str (name != UNBOUND ?
                                           name : as_package(*pkg)->name)));
      symval(tmp) = *pkg;
    }
  else if (method == pull_all)
    {
      lwlock_guard g;
      if (!singlethr_p ())
        KP_VTRY (g.set (interp, &p->lock));

      for (package::iterator it (interp, *pkg); it.valid (); ++it)
        KP_VTRY (update_sym (interp, p, *it, true));
    }
  else
    {
      for (cons::iterator it (interp, arg_2); it.valid (); ++it)
        {
          object sx = *it, tmp;

          if (nksymbol_p (sx))
            {
              tmp = find_sym (interp, *pkg, symname (sx));
              if (!symbol_p (tmp) || symval (tmp) == UNBOUND)
                return (interp->raise ("pkg-error",
                                       KP_SPRINTF (interp, "symbol %Q could not"
                                                   " be found in package %Q",
                                                   symname (sx),
                                                   as_package(*pkg)->name)));

              KP_VTRY (update_sym (interp, p, tmp, true));
            }
          else if ((sx = pull_list_p (sx, tmp)) == UNBOUND)
            return (interp->raise ("arg-error", "expected a name or "
                                   "list as pull spec"));
          else
            {
              object s2 = find_sym (interp, *pkg, symname (sx));
              if (!symbol_p (s2))
                return (interp->raise ("pkg-error",
                                       KP_SPRINTF (interp, "symbol %Q could "
                                                   "not be found in package %Q",
                                                   symname (sx), name)));

              tmp = KP_TRY (pkg_insert (interp, p, symname (tmp),
                                        as_symbol(s2)->vo_flags, true));

              KP_VTRY (check_sym_flags (interp, tmp, s2));
              symval(tmp) = symval (s2);
            }
        }
    }

  kp_return (*pkg);
}

static int
do_init_symbols (interpreter *interp)
{
  int ret = init_op::call_deps (interp, &init_threads);
  if (ret != init_op::result_ok)
    return (ret);

  result<object> tmp;

#define ALLOC_PKG(out, name)   \
  tmp = string::make (interp, name);   \
  if (tmp.error_p ())   \
    return (init_op::result_failed);   \
  \
  tmp = alloc_pkg (interp, *tmp, true);   \
  if (tmp.error_p ())   \
    return (init_op::result_failed);   \
  \
  out = *tmp

  ALLOC_PKG (root_package, "*root*");
  ALLOC_PKG (kword_package, "*keyword*");

#undef ALLOC_PKG

  tmp = string::make (interp, "./", 2);
  if (tmp.error_p ())
    return (init_op::result_failed);

  as_package(root_package)->path = *tmp;
  interp->xpkg = root_package;

#define INTERN_WITH(sym, name, flags)   \
  tmp = string::make (interp, name);   \
  if (tmp.error_p ())   \
    return (init_op::result_failed);   \
  \
  tmp = pkg_insert (interp, as_package (root_package), *tmp, flags);   \
  if (tmp.error_p ())   \
    return (init_op::result_failed);   \
  symbol::sym = *tmp

#define INTERN(sym, name)   INTERN_WITH (sym, #name, 0)

  INTERN (comma, unquote);
  INTERN (comma_at, splice);
  INTERN (comma_dot, nsplice);
  INTERN (backquote, backquote);

  INTERN (t, t);
  as_symbol(symbol::t)->vo_full |= FLAGS_CONST | symbol::literal_flag;
  symval(symbol::t) = symbol::t;

  INTERN (nil, nil);
  as_symbol(symbol::nil)->vo_full |= FLAGS_CONST | symbol::literal_flag;
  symval(symbol::nil) = NIL;

  INTERN_WITH (meth_curr, "*meth-curr*", symbol::special_flag);

  const char *sf = SPECFORM_NAMES;
  for (uint32_t i = 0; i < symbol::N_SPECFORMS; ++i)
    {
      uint32_t len = (uint32_t)strlen (sf);
      tmp = string::make (interp, sf, len);

      if (tmp.error_p ())
        return (init_op::result_failed);

      tmp = intern (interp, as_str (*tmp), as_package (root_package),
                    FLAGS_CONST | symbol::specform_flag);
      if (tmp.error_p ())
        return (init_op::result_failed);

      symbol::fast_global_syms[i] = *tmp;
      sf += len + 1;
    }

  if (*sf)
    return (init_op::fail ("more special forms than expected"));

  symbol::quote = find_sym (interp, "quote", 5);

  loaded_packages.init_head ();
  loaded_packages_lock.init (true);

#undef INTERN
#undef INTERN_WITH
  return (init_op::result_ok);
}

init_op init_symbols (do_init_symbols, "symbols");

KP_DECLS_END

